perm filename PP.VLI[VLI,LSP] blob
sn#382053 filedate 1978-09-08 generic text, type T, neo UTF8
; nouvelle version de PHENARETE ;
; 1- nouvelle routine d'entree de texte ;
; 2- nouvelle routine de meta-evaluation ;
; ;
; ;
; quelques fonctions utiles ;
; ;
; quelques initialisations ;
(STATUS 2 19)
(SETQ -sep '> -lpar 8 -rpar 9)
(SETQQ
subr-stan
(CAR CDR DE CONS COND IF SETQ EQ GT LT LE GE NULL NOT GTZ GZP
CADR CDDR PLUS DIFFER ADD1 SUB1 TIMES QUO NEXTL WHILE NUMBP
ZEROP ATOM LISTP)
f-n-subr
(PROG PRINT PRIN1 RETURN CDAR CADDR CADAR CAADR LENGTH APPEND 1+
1- NTH LIST MEMQ READ)
subr-rare () !! (!!))
(SETQ aux (APPEND subr-stan f-n-subr))
(MAPC (OBLIST)
(LAMBDA (l)
(SELECTQ (TYPEFN l)
((SUBR FSUBR)
(COND ((GT (PLENGTH l) 1)
(PUT l ['LAMBDA 'x ['nimmarg ['CONS [QUOTE l] 'x]]]
'spec)
(IF (MEMQ l aux) NIL (NEWL subr-rare l)))))
(NIL))))
(SETQ aux)
(DE litt (-x -y) (IF (ATOM -x) [-x -y] (NCONC1 -x -y)))
(DE liss (-x -y) (IF (ATOM -y) [-x -y] (CONS -x -y)))
(DF defspec (-x) (PUT (CAR -x) (CADR -x) 'spec))
(DF defspecn (-x) (PUT (CAR -x) (CADR -x) 'specn))
(DE erreur (-x -y) (PRINT "erreur :" !! '(!? 10) -x "-->" -y))
(DM getspec (-x) (RPLACA -x 'GET) (RPLACD -x [(CADR -x) ''spec]))
(DM getspecn (-x) (RPLACA -x 'GET)
(RPLACD -x [(CADR -x) ''specn]))
(DM getnum (-x) (RPLACA -x 'GET)
(RPLACD -x [(CADR -x) ''numarg]))
(DM putval (-x) (RPLACA -x 'PUT)
(RPLACD -x [(CADR -x) (CADDR -x) ''val]))
(DM puttyp (-x) (RPLACA -x 'PUT)
(RPLACD -x [(CADR -x) (CADDR -x) ''typ]))
(DM gettyp (-x) (RPLACA -x 'GET) (RPLACD -x [(CADR -x) ''typ]))
(DM predicat (-x) (RPLACA -x 'EQ)
(RPLACD -x [''predicat ['GET (CADR -x) ''typ]]))
(DMO !! () (TERPRI))
(DMO !? (n) (SPACES n))
(DE notftn (-x -y)
(OR
(NUMBP -x)
(EQ -x T)
(NULL -x)
(IF -y
NIL
(OR
(MEMQ -x ffnvar)
(MEMQ -x varloc)
(MEMQ -x varglob)))))
(DM getexp (-x) (RPLACA -x 'GET) (RPLACD -x [(CADR -x) ''exp]))
; appels de PHENARETE : PHF PHS PHE ;
; ;
; ;
(DE phf (filo . fili) (EVAL (CONS 'PHF (CONS filo fili))))
(DE PHF (filo . fili)
; PHENARETE appliquee a une file ;
(DE EOF ()
(COND
((NULL fili)
(STATUS 1 20)
; repasse en mode tty ;
(STATUS 11 '?)
; repasse en prefixe "?" ;
(STATUS 2 10)
(SETQ %%c NIL)
(INPUT)
(OUTPUT)
(REMPROP 'EOF 'EXPR)
(RESET))
(T (STATUS 1 10)
; imprime les caracteres lus ;
(INPUT (NEXTL fili))
(WHILE T
(phs)
(TERPRI)
(SPACES 10)
(PRINC '* 40)
(TERPRI 2)))))
(IF filo
(IF (ATOM filo)
(OUTPUT ['DSK (CONS filo 'phe)])
(OUTPUT filo))
(OUTPUT filo))
(SETQ %%c T)
(STATUS 2 20)
; passage en mode DSK ;
(EOF))
(DE phs () (PHS))
(DE PHS ()
; PHENARETE appliquee a une S-expression ;
(ESCAPE exit
(init)
(test (PRINT (pread)))))
(DF phe (x) (EVAL (CONS 'PHF x)))
(DF PHE (x)
; PHENARETE appliquee a chacune des fonctions de -x ;
(WHILE x
(init)
(SETQ aux1 (GET (CAR x) 'EXPR))
(IF aux1
(test (MCONS 'DE (NEXTL x) (CDR aux1)))
(PRINT !! !! "je ne peut comprendre que des EXPRs : "
!! (NEXTL x) "n'en fait pas partie"))))
; liste de variables : varlist eti alpha varstore ;
;;
; ;
(DE varlist (-x)
(COND
((ATOM (CAR -x))
(COND
((NULL (CAR -x)) (SETQ help (CDR -x)) NIL)
((alpha (CAR -x))
(CONS (CAR -x) (varlist (CDR -x))))
((getspec (CAR -x)) (SETQ help (NCONS -x)) NIL)
((CONS (eti (CAR -x)) (varlist (CDR -x))))))
((OR
(getspec (CAAR -x))
(AND
(ATOM (CAAR -x))
(GT (PLENGTH (CAAR -x)) 1)
(aehnli (CAAR -x)))
(AND
(LISTP (CAAR -x))
(OR (predicat (CAAAR -x)) (EQ (CAAAR -x) 'LAMBDA))))
(SETQ help -x)
NIL)
((varlist (NCONC (CAR -x) (CDR -x))))))
(DE eti (-x) (IF (NUMBP -x) (GENSYM 'AAA -x) -x))
(DE alpha (-x) (AND (LITATOM -x) (EQ (PLENGTH -x) 1)))
(DE varstore (-x -y)
; garder la liste de variables declarees ;
; y = ffnvar OU varloc ;
(SET -y (REVERSE (EVAL -y)))
(PUSH (APPEND -x (COPY help)))
(IF -x
(MAPC -x
(LAMBDA (-xx)
(IF (MEMQ -xx (EVAL -y))
(erreur "variables plusieurs fois declaree :" -xx)
(SET -y (CONS -xx (EVAL -y)))
(puttyp -xx 'un)
(putval -xx NIL)))))
(SET -y (REVERSE (EVAL -y))))
; fonctions auxiliaires pour les chaines : strg strg1 ;
(DE strg (-x)
(COND
((NULL -x) "")
((ATOM -x) (STRING -x))
((CONCAT "( " (strg1 -x) " )"))))
(DE strg1 (-x)
(COND
((NULL -x) " ")
((ATOM (CAR -x))
(CONCAT (STRING (CAR -x)) " " (strg1 (CDR -x))))
((CONCAT " ( " (strg1 (CAR -x)) " ) " (strg1 (CDR -x))))))
; procedures de lecture : readline -var? ratom pread read- ;
;;
(DE readline ()
; lit une ligne de texte en ;
; convertissant tout les caracteres ;
; en caracteres majuscules ;
(MAPCAR (MAKLIST (READSTR))
(LAMBDA (-x)
(SETQ
-x
(IF (LE 97 (CASCII -x) 123)
(ASCII (- (CASCII -x) 32))
-x))
(IF %%c (PRINC -x) -x))))
(DE -var? (-x -y)
(IF ind
(COND
((ZEROP ind)
; c'est le nom d'une fonction ;
(SETQ ind T ffnvar (CONS -x ffnvar) a1 -x lu 4))
((MEMQ -x '(PROG DE LAMBDA))
(SETQ ind T)
(-var? -x T))
((OR (notftn -x T) (getspec -x))
(SETQ ind NIL a1 -x lu 4))
((SETQ ffnvar (CONS -x ffnvar) a1 -x lu 4)))
(IF -y
NIL
(SETQ aux1 (aehnlich -x))
(IF aux1 (SETQ -x aux1)))
(COND
((OR (notftn -x) (getspec -x))
(IF (MEMQ -x '(PROG DE LAMBDA))
(SETQ ind (IF (EQ -x 'DE) 0 T)))
(SETQ a1 -x lu 4)
(IFN -y (SETQ aux1 NIL)))
((ATOM -x) (SETQ a1 -x lu 4) (IFN -y (SETQ aux1 NIL)))
((SETQ aux1 -x) (ratom)))))
(DE ratom (-x -y -z)
(AND
(NULL -aux)
(NULL aux1)
(NULL ligne)
(PROGN
(STATUS 11 '>)
(SETQ ligne (readline))
(STATUS 11 '?)))
(IF (AND (EQ (CAR ligne) -sep) (EQ (CADR ligne) -sep))
(SETQ -aux T ligne (CDR ligne)))
(COND
((NULL aux1)
(SETQ -y (IF -aux '/) (NEXTL ligne)))
(COND
(-z (IF (EQ -y '/;) (ratom) (ratom NIL NIL T)))
((AND (NULL -x) (EQ -y '/ )) (ratom))
((OR
(EQ -y '/ )
(AND (MEMQ -y '(/. /) /( /' /;)) -x (NEWL ligne -y)))
(SETQ -y (APPLY 'GENSYM (REVERSE -x)))
(-var? -y))
((NOT (MEMQ -y '(/. /( /) /' /;)))
(ratom (CONS -y -x)))
((EQ -y '/') (-var? QUOTE))
((EQ -y '/;) (ratom NIL NIL T))
((SETQ lu -y))))
(-z (IF (EQ (NEXTL aux1) '/;) (ratom) (ratom NIL NIL T)))
((NOT (MEMQ (CAR aux1) '(/. /( /) /' /;)))
(-var? (NEXTL aux1) T))
((EQ (CAR aux1) '/') (NEXTL aux1) (-var? QUOTE T))
((EQ (CAR aux1) '/;) (NEXTL aux1) (ratom NIL NIL T))
((SETQ lu (NEXTL aux1)))))
(DE pread (lu a1 last lastr ind -aux)
(SETQ aux1 NIL aehnlich T)
(aread)
(SETQ aehnlich NIL)
(TERPRI)
(IF -aux (NEXTL ligne))
a1)
(DE aread ()
(ratom)
(COND
((EQ lu 4) a1)
((NEQ lu '/() (erreur "lecture" ")") (aread))
(T (read1))))
(DE read1 () (SETQ last (SETQ lastr (CONS))) (read2))
(DE read2 ()
(ratom)
(COND
((EQ lu '/)) (endrea))
((EQ lu 4) (read4))
((NEQ lu '/.) (read3))
(T ; cas du point ;
(PUSH last lastr)
(aread)
(SETQ lastr (POP) last (POP))
(ratom)
(IF (NEQ lu '/)) (erreur "lecture" "."))
(RPLACD last a1)
(endrea))))
(DE read3 ()
(PUSH last lastr)
(read1)
(SETQ lastr (POP) last (POP))
(read4))
(DE read4 () (RPLACD last (NCONS a1)) (NEXTL last) (read2))
(DE endrea () (SETQ a1 (CDR lastr) lastr NIL) a1)
; initialisations ;
(SETQ :MEM4 (+ (STATUS 42 1) 4))
(DE init (;; -x)
(OR -x (SETQ rec NIL))
(MAPC '(ffnvar ligne varloc label refav)
(LAMBDA (-x) (MAPC (EVAL -x) 'RPLACD)))
(MAPC
'(ffn ffnvar refav loopvar icond iprog varloc label retrn
aehnlich ligne aux1 aux erreur -rest -indif varglob %lll1 %lll2
hypval hypo wht2 ibeisp help1 find wht typ modif val lcond aux
help stack) 'SET)
(SETQ profo 0))
(DE init1 ()
(MAPC '(ffnvar ligne varloc label refav) 'SET)
(SETQ %lll3 NIL %%c NIL qqc 'qqc)
(distr (PLUS ADD1 SUB1 DIFFER) 0 neutre)
(distr (TIMES QUO) 1 neutre)
(distr
(TERPRI CLRBIT SETBIT STATUS PRINT PRIN1 PRINC SPACES TTAB NEXTL
PAGE GO GOTO PROG IF AND OR RETURN EVAL WHILE ESCAPE SETQ SETQQ
SET RPLACA RPLACD NCONC NCONC1 PUT MAPC MAP MAPCAR RETURN)
T topl)
(distr (NEXTL SETQ SET SETQQ RPLACA RPLACD NCONC NCONC1 PUT)
T phys)
(distr
(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR
CDDAR CDDDR MAPC MAP MAPCAR REVERSE NEXTL NCONC NCONC1 APPEND
COPY) 'LISTP arg1)
(distr
(ADD1 1+ 1- SUB1 GTZ ZEROP GZP PAGE SWITCH STATUS SPACES DIFFER
TIMES QUO REM PLUS GT GE LT LE NTH - + *) 'NUMBP arg1)
(distr (STATUS QUO TIMES PLUS GT GE LT LE * - +) 'NUMBP arg2)
(distr (GO EQ NEQ MEMQ GOTO) 'ATOM arg1)
(distr
(ADD1 SUB1 1+ 1- TIMES * DIFFER - PLUS + REM QUO LENGTH)
'NUMBP val)
(distr
(CDR CDAR CDDR CDDAR CDADR CDDAR CDDDR CDADAR MAPCAR REVERSE
APPEND COPY NCONC NCONC1 OBLIST SUBST LIST NTH) 'LISTP val)
(distr (PUT GENSYM ATOM ZEROP GT GE LE LT GZP GTZ NULL NOT)
'ATOM val)
(distr
(NOT NULL GTZ GZP NUMBP LISTP ATOM ZEROP SWITCH EQ NEQ GT GE LT
LE MEMQ EQUAL OR AND MEMBER) 'predicat typ)
(distr (MEMQ NCONC CONS NTH APPEND) 'LISTP arg2)
(distr (EQ NEQ) 'ATOM arg2)
(MAPC (OBLIST)
'(LAMBDA (L)
(SELECTQ (TYPEFN L)
(SUBR
(PUT L
(SELECTQ
(1-
(LOGSHIFT (STATUS 41 (+ :MEM4 (LOC L))) -18))
(0 0)
(1 1)
(2 2)
(3 3)
(-1))
'numarg))
(FSUBR (PUT L -1 'numarg))
(NIL)))))
(DF distr (-x)
( (LAMBDA (val ind)
(MAPC (CAR -x) (LAMBDA (xx) (PUT xx val ind))))
(EVAL (CADR -x)) (CADDR -x)))
; aehnlich et co ;
; correction d'erreur d'orthographe ;
(DE aehnli (x ;; zz xx)
(COND
((notftn x) (IF xx x NIL)) ((aehn x NIL NIL zz))))))
(DM implode (x) (RPLACA x 'APPLY) (RPLACD x [''GENSYM (CADR x)]))
(DE aehnlich (x ;; zz xx)
; regarde si x est un atome connu , en se servant ;
; eventuellement d'une liste zz de possibilites ;
; utilise et change les variables globales suivantes ;
; aux1 aux2 compt ainsi que le CDR de propo ;
(COND
((OR (notftn x) (getspec x))
; cas simple ;
(IF xx (IF (OR (NUMBP x) (EQ x T)) NIL x) NIL))
((EQ (CAR (LAST (SETQ aux2 (EXPLODE x)))) -rpar)
(IF
(SETQ
aux1
(aehnlich (implode (REVERSE (CDR (REVERSE aux2))))
NIL T)) (litt aux1 '/)) (aehn x NIL NIL zz)))
((EQ (CAR (LAST aux2)) -lpar)
(IF
(SETQ
aux1
(aehnlich (implode (REVERSE (CDR (REVERSE aux2))))
NIL T)) (litt aux1 '/() (aehn x NIL NIL zz)))
((EQ (CAR aux2) -lpar)
(IF (SETQ aux1 (aehnlich (implode (CDR aux2)) NIL T))
(liss '/( aux1)
(aehn x NIL NIL zz)))
((EQ (CAR aux2) -rpar)
(IF (SETQ aux1 (aehnlich (implode (CDR aux2)) NIL T))
(liss '/) aux1)
(aehn x NIL NIL zz)))
((ESCAPE ex
(SETQ aux1 (APPEND ffnvar (APPEND varloc varglob)))
(MAPC aux2
(LAMBDA (x) (IF (MEMQ x aux1) NIL (ex NIL))))
(ex aux2)))
((aehn x NIL NIL zz))))
(DE aehn (x ;; yy z zz)
; si l'atome n'est pas connu ;
(MAPC (IF yy (EVAL yy) (OR zz subr-stan))
(FUNCTION (LAMBDA (xx)
(ESCAPE exi
(SETQ aux1 (EXPLODE xx) yy (EXPLODE x) compt 0)
(WHILE (OR aux1 yy)
(INCR compt)
(COND
((AND
(NULL aux1)
; cas comme WHILEL --> WHILE L ;
(SETQ
aux2
((IF aehnlich 'aehnlich 'aehnli)
(implode yy) NIL T)))
(exi
(ADDPROP 'propo
(IF (ATOM aux2)
[xx aux2]
(CONS xx aux2)) compt)))
((EQ (CAR aux1) (CAR yy))
; tout va bien ! ;
(NEXTL aux1)
(NEXTL yy))
((OR
(EQUAL (CDR aux1) yy)
; oublie d'un caractere ;
(EQUAL (CDR yy) aux1)
; ajout d'un caractere ;
(EQUAL (CDR aux1) (CDR yy))
; difference d'un caractere ;
(AND
; inversion de deux caracteres ;
(EQ (CADR yy) (CAR aux1))
(EQ (CAR yy) (CADR aux1))
(EQUAL (CDDR yy) (CDDR aux1))))
(exi (ADDPROP 'propo xx compt)))
((exi))))))))
(ESCAPE ex
(COND
((NULL (CDR 'propo))
(AND z (ex))
(ex
(OR
(aehn x 'f-n-subr T)
(aehn x 'subr-rare T)
(aehn x 'varloc T)
(aehn x 'varglob T)
(aehn x 'ffnvar T))))
(T (SETQ aux1)
(MAPC (CDR 'propo)
(LAMBDA (xx) (AND (NUMBP xx) (NEWL aux1 xx))))
(COND
((trr aux1)
(COND
(%%c
(PRINT '? x "-->" !!)
(RPLACD 'propo)
(SETQ aux1 (READ))
(ex aux1))
((SETQ
aux1 (getall 'propo (APPLY 'MAX aux1)))
(RPLACD 'propo)
(errgrave x aux1))))
((SETQ aux1 (GET 'propo (APPLY 'MAX aux1)))
(RPLACD 'propo)
(IF %lll3 (erreur "nom" ['? x "-->" aux1]))
(ex aux1)))))))
(DE trr (x y z)
(SETQ y (APPLY 'MAX x) z 0)
(WHILE x (AND (EQ (NEXTL x) y) (INCR z)))
(GT z 1))
(DE getall (x y)
(MAPT (CDR x)
(LAMBDA (x) (AND (EQ (CAR x) y)(CADR x)))))))))))
(DE errgrave (x y) (exit ["erreur dramatique" x "-->" y])))))))
; test test1 test2 ;
; ;
; moniteurs ;
(DE test (-x -y)
(ESCAPE exit
(test1 -x -y)
(TERPRI)
(COND
(aux
(PRINT "proposition finale :" !!)
; (EVAL aux) ;
(PRETTYP aux)))
(PRINT !! '(!? 20)
"a part ca , votre fonction semble bonne." !!)))
(DE test1 (-x -y)
(init -y)
(COND
((ATOM -x) (SETQ aux -x))
((NUMBP (CAR -x)) (test1 (CDR -x) -y))
((SETQ aux1 (getspec (CAR -x)))
(SETQ aux (APPLY aux1 (CDR -x)))
; (OR (test2)(PROGN (EVAL aux)(SETQ aux)))) ;)
((SETQ aux (prognn (SETQ help -x) -1))
(IF (AND (EQ (LENGTH aux) 1) (LISTP (CAR aux)))
(SETQ aux (CAR aux))))))
(DE test2 ()
; boucle des approximations ;
(PUSH (COPY aux))
(APPLY (getspecn (CAR aux)) (CDR aux))
(IF (EQUAL aux (POP)) T (test2)))
; ade etiq1 etiq2 iprog ;
(DE ade (-x y)
(IF iprog
NIL
(COND
((etiq2 'ffnvar)
(AND
refav
(erreur "GO a une etiquette inexistante" refav))
(PUT ffn ffnvar 'ffnvar)
(PUT ffn (LENGTH ffnvar) 'numarg)))
(AND
(etiq1)
(SETQ
aux
(NCONC [(CAR aux) (CADR aux) (caddr aux)]
[(mcons 'PROG NIL (CDDDR aux))]))))
(IF %lll2
(POP)
(ESCAPE ex
(MAPC ffnvar
(LAMBDA (x) (IF (GET x 'ap) NIL (ex (SETQ -x T))))))
(IFN -x
(POP)
(SETQ
-x (POP)
; liste de variables ; y
(PUSH ffnvar) ffnvar
NIL)
(ESCAPE ex
(MAPC y
(LAMBDA (x ;; z)
(SETQ aehnlich T)
(IF (GET x 'ap)
(SETQ ffnvar (APPEND1 ffnvar x))
(SETQ z (aehnlich x))
(IFN z
NIL
(POP)
(IF
(MEMQ z
(APPEND ffnvar
(APPEND varglob varloc)))
(SETQ z x))
(RPLACA (CDDR aux) ffnvar)
(RPLACD (CDDR aux)
(IF (ATOM z)
(CONS z (CDR (MEMQ x -x)))
(APPEND
(IF (EQ (CAR z) '/)) (CDR z) z)
(CDR (MEMQ x -x)))))
(SETQ
ligne
(MAKLIST
(CONCAT (strg aux) (STRING '>>)
ligne)))
(SETQ %lll3 T aux (pread) %lll3 NIL)
(ex (test1 aux))))))
(SETQ ffnvar (POP)))))
(SETQ y NIL)
(MAPC ffnvar
(LAMBDA (x)
(IF (GET x 'ap)
(SETQ y (CONS x y))
(erreur "variable non utilisee" x))))
(RPLACA (CDDR aux) (SETQ ffnvar (REVERSE y)))
(PUT ffn (LENGTH ffnvar) 'numarg))
(DE etiq1 (x)
; resolution de quelques cas critiques ;
(COND
(label
(SETQ aux1 label)
(WHILE aux1
(COND
((GET (CAR aux1) 'ab)
(PUT (CAR aux1)
(CDR (MEMQ (CAR aux1) aux))
'val)
(SETQ x T))
((EQ (LENGTH (MEMQ (CAR aux1) aux)) 1)
(SETQ label (DELQ x label)))
((SETQ
aux (DELQ (CAR aux1) aux)
label (DELQ (CAR aux1) label))))
(NEXTL aux1))
x)))
(DE iprog ()
(COND
((etiq2 'varloc)
(AND
refav
(erreur "GO a une etiquette inexistante" refav))
(AND ffn (PUT ffn varloc 'varloc))))
(etiq1))
(DE etiq2 (lvar)
(ESCAPE ex
(IF refav
(MAPC refav
(LAMBDA (x)
(COND
((MEMQ x label) (SETQ refav (DELQ x refav)))
((MEMQ x (EVAL lvar))
(SETQ refav (DELQ x refav))
(NEWL label x)
(PUT x
(SETQ
aux1
(IF (EQ lvar 'ffnvar)
(CDDDR aux)
(CDDR aux)))
'val)
(RPLACD
(IF (EQ lvar 'ffnvar) (CDR aux) aux)
(CONS (SET lvar (DELQ x (EVAL lvar)))
(CONS x aux1)))
(ex T))))))))
; save & restore ;
(DE restore ()
(MAPC
'(help wht find help1 wht2 hypo hypval %lll3 %lll2 %lll1 aux
-indif varglob retrn iprog icond loopvar ffn refav label varloc
ffnvar rec -rest) (LAMBDA (x) (SET x (POP)))))
(DE save ()
(MAPC
'(-rest rec ffnvar varloc label refav ffn loopvar icond iprog
retrn varglob -indif aux %lll1 %lll2 %lll3 hypval hypo wht2
help1 find wht help)
(LAMBDA (x) (PUSH (EVAL x)) (SET x NIL))))
; moniteurs 1ere lecture : nimmarg & prognn ;
; ;
(DE nimmarg (-x)
(IF (EQUAL -x help) (NEXTL help))
(COND
((MEMQ (CAR -x) [ffn 'SELF])
(puttyp ffn 'rec)
(CONS (CAR -x) (prognn (CDR -x) (getnum ffn))))
(lcond ; a regler plus tard ;)
((MEMQ (CAR -x) '(IF IFN))
(CONS (CAR -x)
(APPEND (prognn (CDR -x) 1)
(PROGN
(NEWL -indif T)
(APPEND (prognn (IF -rest (NEXTL -rest) help) 1)
(prognn (IF -rest (NEXTL -rest) help) -1))))))
((CONS (CAR -x) (prognn (CDR -x) (getnum (CAR -x)))))))
(DE prognn (-x ; eventuellement nombre d'expressions ; -y)
(SETQ -globy -y)
(IF (EQUAL -x help) (NEXTL help))
(COND
((AND -y (ZEROP -y)) (IF -x (NEWL -rest -x)) NIL)
((NULL -x)
(IF (AND -y (GZP -y))
(IF -rest
(prognn (NEXTL -rest) -y)
(IF help (prognn help -y)
(CONS NIL (prognn help (1- -y)))))
; c'est fini ;
NIL))
((ATOM (CAR -x))
(IF -indif (NEXTL -indif))
(COND
((notftn (CAR -x))
(COND
(lcond ; a regler ulterieurement ;)
((AND -y (GZP -y))
(IF
(OR
(NUMBP (CAR -x))
(MEMQ (CAR -x) '(NIL T)))
NIL
(PUT (CAR -x) T 'ap))
(CONS (CAR -x) (prognn (CDR -x) (1- -y))))
((CDR -x)
(PRINT "a quoi sert le" (CAR -x) "dans" -x
'?)
(prognn (CDR -x) -y))
(T (IF
(OR
(NUMBP (CAR -x))
(MEMQ (CAR -x) '(NIL T)))
NIL
(PUT (CAR -x) T 'ap))
-x)))
((SETQ aux1 (getspec (CAR -x)))
; fonction , manque "(" ;
(CONS (APPLY aux1 (CDR -x))
(prognn (IF -rest (NEXTL -rest) help)
(IF (AND -y (GZP -y)) (1- -y) -y))))
((NULL -y)
; etiquette ;
(NEWL label (eti (CAR -x)))
(CONS (CAR -x) (prognn (CDR -x) -y)))
((NEWL varglob (CAR -x))
(prognn -x (IF (AND -y (GZP -y))(1- -y) -y)))))
((ATOM (CAAR -x))
(IF -indif (NEXTL -indif))
(COND
(lcond ; a regler ulterieurement ;)
((SETQ aux1 (getspec (CAAR -x)))
(IF (CDR -x) (NEWL -rest (CDR -x)))
(CONS (APPLY aux1 (CDAR -x))
(prognn (IF -rest (NEXTL -rest) help)
(IF (AND -y (GZP -y)) (1- -y) -y))))
((prognn (APPEND (CAR -x) (CDR -x)) -y))))
((ATOM (CAAAR -x))
(COND
((EQ (CAAAR -x) 'LAMBDA)
(IF -indif (NEXTL -indif))
(IF (CDR -x) (NEWL -rest (CDR -x)))
(CONS (aplambda (CAR -x))
(prognn (IF -rest (NEXTL -rest) help)
(IF (AND -y (GZP -y)) (1- -y) -y))))
((predicat (CAAAR -x))
(IF -indif (NEXTL -indif))
(IF (CDR -x) (NEWL -rest (CDR -x)))
(CONS (prognn ['COND (CAR -x)] -y)
(prognn (IF -rest (NEXTL -rest) help)
(IF (AND -y (GZP -y)) (1- -y) -y))))
(-indif
(PUSH (CDR -x))
(APPEND
(prognn (CONS 'PROGN (CAR -x)) -y ;;
(NEXTL -indif))
(PROGN
(IF (SETQ aux1 (POP))
(NEWL -rest aux1))
(prognn (IF -rest (NEXTL -rest) help)
(IF (AND -y (gzp -y)) (1- -y) -y)))))
((prognn (APPEND (CAR -x) (CDR -x)) -y))))
((prognn (APPEND (CAR -x) (CDR -x)) -y))))))
; creation des specialistes standard : GO QUOTE LAMBDA SETQ DE ;
(DE init2 ()
;;
; --- GO --- ;
;;
(defspec GO
(LAMBDA -x
(IF (EQUAL -x help) (NEXTL help))
(COND
((ATOM (CAR -x))
(AND (NUMBP (CAR -x)) (RPLACA -x (eti (CAR -x))))
(PUT (CAR -x) T 'ab)
(IF (MEMQ -x label)
NIL
(IF (MEMQ (CAR -x) refav)
NIL
(NEWL refav (CAR -x))))
(IF (CDR -x) (NEWL -rest (CDR -x)))
['GO (CAR -x)])
((getspec (CAAR -x))
(IF
(SETQ
aux1
(aehnli 'GO
(APPEND ffnvar (APPEND varloc varglob))))
(prognn
(IF (ATOM aux1)
(CONS aux1 (CDR -x))
(APPEND aux1 (CDR -x))) -globy)
(exit ["sais pas que faire avec"
(CONS 'GO -x)])))
((nimmarg (CONS 'GO (APPEND (CAR -x) (CDR -x))))))))
;;
; --- QUOTE --- ;
;;
(defspec QUOTE
(LAMBDA -x
(IF (EQUAL help -x) (NEXTL help))
[QUOTE
(IF (AND (ATOM (CAR -x)) (EQ (CAR -x) 'LAMBDA))
(APPLY (getspec 'LAMBDA) (CDR -x))
(IF (AND (LISTP (CAR -x)) (EQ (CAAR -x) 'LAMBDA))
(PROGN
(IF (CDR -x) (NEWL -rest (CDR -x)))
(APPLY (getspec 'LAMBDA) (CDAR -x)))
(IF (CDR -x) (NEWL -rest (CDR -x)))
(CAR -x)))]))
;;
; --- LAMBDA --- ;
;;
(defspec LAMBDA
(LAMBDA -x
(IF (EQUAL help -x) (NEXTL help))
(SETQ aux1 (APPEND varloc (APPEND ffnvar varglob)))
(save)
(SETQ varglob aux1)
(test (MCONS 'DE (PUSH (GENSYM)) -x))
(SETQ aux1 (POP))
(SETQ lambvar (LENGTH ffnvar))
(restore)
aux1))
;;
; --- SETQ --- ;
;;
(defspec SETQ
(LAMBDA -x
(IF (EQUAL help -x) (NEXTL help))
(SETQ aux1 (prognn -x 1))
(IF (ATOM (CAR aux1))
(CONS 'SETQ (-atli aux1 T))
(PRINT (getexp 'SETQ) !! "ici" (CONS 'SETQ aux1) !!
"le 1er argument est non-atomique" !!
"je change donc le SETQ en SET")
(nimmarg (CONS 'SET aux1)))))
;;
; --- DE --- ;
;;
(defspec DE (LAMBDA -x
(IF (EQUAL help -x) (NEXTL help))
(COND
((OR ffn iprog)
; definition a l'interieur d'une autre fonction ;
(save)
(test (CONS 'DE -x))
(restore))
(T (WHILE (LISTP (CAR -x))
; forme : (DE (foo a b) ... ;
(SETQ -x (NCONC (CAR -x) (CDR -x))))
(SETQ ffn (CAR -x))
(IF (AND (getspec ffn) (NOT (GET ffn 'utilisateur)))
(exit (erreur "fonction standard : " ffn)))
(NEWL f-n-subr ffn)
(RPLACD ffn)
(PUT ffn T 'utilisateur)
(PUT ffn
['LAMBDA 'x ['nimmarg ['CONS [QUOTE ffn] 'x]]]
'spec)
(varstore (varlist (CDR -x)) 'ffnvar)
(PUT ffn ffnvar 'ffnvar)
(PUT ffn (LENGTH ffnvar) 'numarg)
(SETQ aux (MCONS 'DE ffn ffnvar (prognn help)))
(ade)
aux))) ()))
; -atli & aplambda ;
(DE -atli (-x -y)
(IF -y
(IF (AND (CAR -x) (ATOM (CAR -x)))
(CONS (CAR -x)
(-atli (prognn (IF -rest (NEXTL -rest) help) 1) NIL))
(IF -x (NEWL -rest -x))
NIL)
(APPEND -x
(-atli (prognn (IF -rest (NEXTL -rest) help) 1) T))))
(DE aplambda (-x)
(IF (CDR -x) (NEWL -rest (CDR -x)))
(CONS (APPLY (getspec 'LAMBDA) (CDAR -x))
(prognn (IF -rest (NEXTL -rest) help) lambvar)))
; --- miscellaneous --- ;
(init1)
(init2)
(init)
(SETQ AE 'aehnlich)
(SETQQ !! (!!))
(STATUS 1 19)
(STATUS 2 27)
; END OF FILE : (DSK (PP . VLI) NIL) 30-JUN-78 01:07:11 ;